Chip 2000 July/Chip_2000-07_cd.bin/sharewar/vbshpdfc/Install.exe/VB Shaped Form Creator.CAB/DropDown.frm

Text File | 1999-12-22 | 14KB | 340 lines

VERSION 5.00
Begin VB.Form Mainwin
   AutoRedraw      =   -1  'True
   BorderStyle     =   0  'None
   Caption         =   "VBSFC DropDown Demo"
   ClientHeight    =   3195
   ClientLeft      =   3645
   ClientTop       =   3000
   ClientWidth     =   4695
   ControlBox      =   0   'False
   MaxButton       =   0   'False
   Picture         =   "DropDown.frx":0000
   ScaleHeight     =   213
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   313
   Begin VB.PictureBox ControlHolder
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      Height          =   1635
      Left            =   60
      ScaleHeight     =   1635
      ScaleWidth      =   4515
      TabIndex        =   4
      Top             =   300
      Width           =   4515
      Begin VB.CommandButton btnDrop
         Caption         =   "More..."
         Default         =   -1  'True
         Height          =   375
         Left            =   3180
         TabIndex        =   5
         Top             =   1200
         Width           =   1155
      End
      Begin VB.Label Label2
         Alignment       =   2  'Center
         Caption         =   "DropDown Demo by Alex Vallat 1999"
         Height          =   195
         Left            =   0
         TabIndex        =   10
         Top             =   0
         Width           =   4575
      End
      Begin VB.Label Label3
         Alignment       =   2  'Center
         Caption         =   "Using Visual Basic Shaped Form Creator 5.9"
         Height          =   255
         Left            =   0
         TabIndex        =   9
         Top             =   300
         Width           =   4575
      End
      Begin VB.Label Link
         Caption         =   "http://www.comports.com/AlexV"
         BeginProperty Font
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   -1  'True
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H8000000D&
         Height          =   195
         Index           =   0
         Left            =   1080
         MouseIcon       =   "DropDown.frx":30E5E
         MousePointer    =   99  'Custom
         TabIndex        =   8
         Top             =   840
         Width           =   2355
      End
      Begin VB.Label Link
         Caption         =   "http://www.comports.com/AlexV/VBSFC.html"
         BeginProperty Font
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   -1  'True
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H8000000D&
         Height          =   195
         Index           =   1
         Left            =   600
         MouseIcon       =   "DropDown.frx":30FB0
         MousePointer    =   99  'Custom
         TabIndex        =   7
         Top             =   600
         Width           =   3315
      End
      Begin VB.Label Link
         Caption         =   "[e-mail]"
         BeginProperty Font
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   -1  'True
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H8000000D&
         Height          =   195
         Index           =   2
         Left            =   60
         MouseIcon       =   "DropDown.frx":31102
         MousePointer    =   99  'Custom
         TabIndex        =   6
         Top             =   1320
         Width           =   1635
      End
   End
   Begin VB.PictureBox DropHolder
      BorderStyle     =   0  'None
      Height          =   1050
      Left            =   120
      Picture         =   "DropDown.frx":31254
      ScaleHeight     =   1050
      ScaleWidth      =   4455
      TabIndex        =   0
      Top             =   1965
      Width           =   4455
      Begin VB.CommandButton btnUp
         Caption         =   "t"
         BeginProperty Font
            Name            =   "Marlett"
            Size            =   8.25
            Charset         =   2
            Weight          =   500
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   165
         Left            =   4100
         TabIndex        =   2
         Top             =   740
         Width           =   165
      End
      Begin VB.Label Label1
         Caption         =   "This part could have some controls in it..."
         Height          =   195
         Left            =   300
         TabIndex        =   3
         Top             =   480
         Width           =   3315
      End
   End
   Begin VB.PictureBox DropBitHider
      BorderStyle     =   0  'None
      Height          =   1005
      Left            =   120
      Picture         =   "DropDown.frx":4067E
      ScaleHeight     =   1005
      ScaleWidth      =   4455
      TabIndex        =   1
      Top             =   1260
      Width           =   4455
   End
   Begin VB.Image TempHolder
      Height          =   255
      Left            =   3180
      Top             =   0
      Visible         =   0   'False
      Width           =   255
   End
   Begin VB.Image CloseHolder
      Height          =   210
      Left            =   3660
      Picture         =   "DropDown.frx":4F034
      Top             =   0
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image MinHolder
      Height          =   210
      Left            =   3420
      Picture         =   "DropDown.frx":4F316
      Top             =   0
      Visible         =   0   'False
      Width           =   240
   End
   Begin VB.Image Min
      Height          =   210
      Left            =   3930
      Picture         =   "DropDown.frx":4F5F8
      Top             =   45
      Width           =   240
   End
   Begin VB.Image CloseB
      Height          =   210
      Left            =   4200
      Picture         =   "DropDown.frx":4F8DA
      Top             =   45
      Width           =   240
   End
End
Attribute VB_Name = "Mainwin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'What are all the picture boxes for?
'DropBitHider:  Hides the dropping part of the form (controls, pictures, etc.) when not in use
'DropHolder:    Contains all the controls and picture for the dropping part of the form
'ControlHolder: Contains normal part controls - so the labels are not hidden by DropBitHider.  If not using labels, then you don't need this.

Option Explicit
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const RGN_COPY = 5
Private ResultRegion As Long, WindowRegion As Long

Private Function CreateFormRegion(ScaleX As Single, ScaleY As Single, OffsetX As Integer, OffsetY As Integer) As Long
'This sub created by VBSFC
    Dim HolderRegion As Long, ObjectRegion As Long, nRet As Long, Counter As Integer
    ResultRegion = CreateRectRgn(0, 0, 0, 0)
    HolderRegion = CreateRectRgn(0, 0, 0, 0)
    ObjectRegion = CreateRoundRectRgn(0 * ScaleX * 15 / Screen.TwipsPerPixelX + OffsetX, 0 * ScaleY * 15 / Screen.TwipsPerPixelY + OffsetY, 313 * ScaleX * 15 / Screen.TwipsPerPixelX + OffsetX, 161 * ScaleY * 15 / Screen.TwipsPerPixelY + OffsetY, 32 * ScaleX * 15 / Screen.TwipsPerPixelX, 32 * ScaleY * 15 / Screen.TwipsPerPixelY)
    nRet = CombineRgn(ResultRegion, ObjectRegion, ObjectRegion, RGN_COPY)
    DeleteObject ObjectRegion
    ObjectRegion = CreateEllipticRgn(0 * ScaleX * 15 / Screen.TwipsPerPixelX + OffsetX, 137 * ScaleY * 15 / Screen.TwipsPerPixelY + OffsetY, 312 * ScaleX * 15 / Screen.TwipsPerPixelX + OffsetX, 184 * ScaleY * 15 / Screen.TwipsPerPixelY + OffsetY)
    nRet = CombineRgn(HolderRegion, ResultRegion, ResultRegion, RGN_COPY)
    nRet = CombineRgn(ResultRegion, HolderRegion, ObjectRegion, 4)
    DeleteObject ObjectRegion
    DeleteObject HolderRegion
    CreateFormRegion = ResultRegion
End Function

Private Sub Form_Load()
    Dim nRet As Long, TempRgn As Long
    'Position the dropping part
    DropHolder.ZOrder 1
    DropHolder.Top = 71

    'Keep a copy of the window region
    WindowRegion = CreateRectRgn(0, 0, 0, 0)
    TempRgn = CreateFormRegion(1, 1, 0, 0)
    nRet = CombineRgn(WindowRegion, TempRgn, 0, RGN_COPY)

    'Set window and hider picture box regions.
    'The hider picture box is necessary to stop the dropping
    'part being visible when not dropped
    nRet = SetWindowRgn(Me.hwnd, TempRgn, True)
    nRet = SetWindowRgn(DropBitHider.hwnd, CreateFormRegion(1, 1, -DropBitHider.Left, -DropBitHider.Top), True)
End Sub

Private Sub btnDrop_Click()
    Animate
End Sub
Private Sub btnUp_Click()
    AnimateReverse
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Y < 19 Then 'If inside titlebar area
        ReleaseCapture
        SendMessage Me.hwnd, &HA1, 2, 0&
    End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
    DeleteObject ResultRegion
    DeleteObject WindowRegion
End Sub
Private Sub Animate()
    Dim Counter As Integer
    For Counter = -64 To 0 Step 4 'If you want larger steps, modify this line (changes drop speed)
        'Adjust window shape
        SetWindowRgn Me.hwnd, 0, False
        SetWindowRgn Me.hwnd, DropRegion(WindowRegion, 1, 1, 0, Counter), True
        'Move dropping part controls and picture
        DropHolder.Top = 131 + Counter
        DoEvents
    Next Counter
End Sub
Private Sub AnimateReverse()
    Dim Counter As Integer
    For Counter = 0 To -64 Step -8 'If you want larger steps, modify this line (changes rise speed)
        SetWindowRgn Me.hwnd, 0, False
        SetWindowRgn Me.hwnd, DropRegion(WindowRegion, 1, 1, 0, Counter), True
        DropHolder.Top = 131 + Counter
        DoEvents
    Next Counter
End Sub
Private Function DropRegion(ByRef CurrentRegion As Long, ScaleX As Single, ScaleY As Single, OffsetX As Integer, OffsetY As Integer) As Long
'Also copied from a VBSFC generated sub
    Dim ObjectRegion As Long
    DeleteObject ResultRegion
    ResultRegion = CreateRectRgn(0, 0, 0, 0)
    ObjectRegion = CreateRoundRectRgn(12 * ScaleX * 15 / Screen.TwipsPerPixelX + OffsetX, 120 * ScaleY * 15 / Screen.TwipsPerPixelY + OffsetY, 300 * ScaleX * 15 / Screen.TwipsPerPixelX + OffsetX, 200 * ScaleY * 15 / Screen.TwipsPerPixelY + OffsetY, 34 * ScaleX * 15 / Screen.TwipsPerPixelX, 34 * ScaleY * 15 / Screen.TwipsPerPixelY)
    CombineRgn ResultRegion, CurrentRegion, ObjectRegion, 2
    DeleteObject ObjectRegion
    DropRegion = ResultRegion
End Function

'Button pressing handling (4 subs):
Private Sub Min_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    TempHolder.Picture = Min.Picture
    Min.Picture = MinHolder.Picture
End Sub
Private Sub Min_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Min.Picture = TempHolder.Picture
    Me.WindowState = 1
End Sub
Private Sub CloseB_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    TempHolder.Picture = CloseB.Picture
    CloseB.Picture = CloseHolder.Picture
End Sub
Private Sub CloseB_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    CloseB.Picture = TempHolder.Picture
    Unload Me
End Sub
'---

Private Sub Link_Click(Index As Integer)
'Internet Linking thing
    If InStr(Link(Index).Caption, "@") <> 0 Then
        LinkTo "mailto:" + Link(Index).Caption
    Else
        LinkTo Link(Index).Caption
    End If
End Sub
Private Sub LinkTo(Address As String)
'Internet Linking thing
    Dim Result As Long
    Result = ShellExecute(Me.hwnd, "open", Address, "", "", 1)
    If Result <= 32 Then Err.Raise 17
End Sub